home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / UNITS / PBXBASE.PAS < prev   
Pascal/Delphi Source File  |  1994-05-03  |  25KB  |  805 lines
  1. {SECTION ..PbXBASE }
  2. UNIT PbXBASE;
  3.  
  4. INTERFACE
  5.  
  6. uses DOS, PbMISC;
  7.  
  8. {
  9. Description:  XBASE File Object(s)
  10.  
  11. Author      : Howard Richoux
  12. Date        : 11/24/93
  13. Last revised: 11/24/93
  14.                2/18/94 new libraries
  15. Application : IBM PC and compatibles, done in Turbo Pascal 7.0
  16. Status      : Placed in the Public Domain by HNR Software 1/29/1994
  17. Published in: none
  18.  
  19. Loosely based on DBLKSTUF
  20. }
  21.  
  22. {SECTION .DEFS }
  23. const   BOF          = -1;    { Beginning of .DBF file. }
  24.         DBOK         =  0;    { No errors. }
  25.         EOF          =  1;    { End of DBF file. }
  26.         READ_ERR     =  2;    { Blockread error }
  27.         CLOSE_ERR    =  3;    { Error closing .DBF file }
  28.         REWRITE_ERR  = -2;
  29.         POSITION_ERR = -3;
  30.  
  31.         dbREADONLY   = true;
  32.         dbREADWRITE  = false;
  33.  
  34. {*** modified 2/10/94 - original is on \hnrold\PbXBASE.sav }
  35. type  rdef_type = record            { Dbase record definitions we use }
  36.         name       :string[10];
  37.         rtype      :char;           { type of record - C,N,D,L,etc.         }
  38.         width      :byte;           { total field width of this record      }
  39.         decp       :byte;           { number of digits to right of decimal  }
  40.         stloc      :integer;        { offset from start of field where this }
  41.         end;
  42.  
  43.  
  44. type  db4head_type = record  { Dbase III + header definition        }
  45.         dbvno        :byte;  { version number (03h or 83h ) }
  46.         updyr        :byte;  { last update YY MM DD         }
  47.         updmo        :byte;
  48.         upddy        :byte;
  49.         no_rec       :longint; { number of record in database }
  50.         header_bytes :integer; { number of bytes in header }
  51.         rec_bytes    :integer; { number of bytes in records }
  52.         tmp          :array[1..20] of char;   { reserved bytes in header }
  53.         end;
  54.  
  55.  
  56. type  db4ref_type = record          { Actual header field def record        }
  57.         name       :array[1..11] of char; { Name of this record             }
  58.         rtype      :char;           { type of record - C,N,D,L,etc.         }
  59.         fld_addr   :longint;        { not used }
  60.         width      :byte;           { total field width of this record      }
  61.         decp       :byte;           { number of digits to right of decimal  }
  62.         multi_user :integer;        { reserved for multi user }
  63.         work_id    :byte;           { Work area ID }
  64.         m_user     :integer;        { reserved for multi_user }
  65.         set_fields :byte;           { SET_FIELDS flag }
  66.         resrvd     :array[1..8] of byte;      { 8 bytes reserved }
  67.         end;                           { record starts                         }
  68.  
  69.  
  70. {-}
  71. {SECTION .XBASE_DBF_object }
  72. {PAGE}
  73.  
  74. const bufmax = 2048;  { DBASE Spec is 4096 }
  75.  
  76. TYPE  XBASE_DBF_object = OBJECT
  77.         opened   : boolean;                   { is this file open?}
  78.         writepermitted : boolean;             { based on open mode }
  79.         dbbuf    : array[1..bufmax] of char;    { Dbase record }
  80.         dbhead   : db4head_type;              { header of DBF file }
  81.         rstru    : array[1..50] of rdef_type; { version of the rec structure }
  82.         no_col   : integer;                   { number of columns in database }
  83.         dbfin    : file;
  84.         rec_stru : db4ref_type;               { actual database rec structure }
  85.         infile   : string;                    { name of database }
  86.         db_rec_no: longint;                   { Present record of DBF file }
  87.         err      : integer;
  88.  
  89.         Procedure Init(dbfilename:string; readonly : boolean);
  90.         Procedure done;
  91.         Function  NoError : boolean;
  92.  
  93.         Procedure dbshowstruc;
  94.         Procedure dblistrecs;           {lists all records in SDF format }
  95.         Function  dbclose:boolean;       {closes dbase file }
  96.         Function  dbfldno(fname:string):integer;  {Field name -> Field Number }
  97.         Function  dbfldname(fnum:integer):string; {Field number -> Field Name }
  98.         Function  dbfldrtype(fnum:integer):char;
  99.         Function  dbfldwidth(fnum:integer):integer;
  100.         Function  dbflddecp (fnum:integer):integer;
  101.         Function  dbnumfields : integer;
  102.         Function  dbrecsize : integer;
  103.         Function  dbnumrecs : integer;
  104.         Procedure dbcleardbbuf;
  105.  
  106.         Function  dbstr(fldno:integer):string;     {Fetches string value of field }
  107.         Function  dbint(fldno:integer):integer;    {Fetches integer value of field }
  108.         Function  dblong(fldno:integer):longint;   {Fetches longint value of field }
  109.         Function  dbreal(fldno:integer):real;      {Fetches real value of field }
  110.         Function  dblogic(fldno:integer):boolean;  {Fetches boolean value of field }
  111.  
  112.         Function  dbdeleted:boolean;   {Returns true if current record is deleted }
  113.         Function  dbrecno:longint;                  {Returns current record number }
  114.  
  115.         Function  dbposition(rec_no:longint):boolean; {does the work}
  116.         Function  dbgoto(rec_no:longint):boolean;   {Goto record rec_no }
  117.         Function  dbskip(rec_no:longint):boolean;   {Move forward and read next }
  118.         Function  dbtop:boolean;                    {Move to record 1 and read }
  119.         Function  dbbottom:boolean;                 {Move to last record and read }
  120.  
  121.         Procedure dbputstr(fldno:integer; s : string);
  122.         Procedure dbputdate(fldno:integer; s : string);
  123.         Procedure dbputint(fldno:integer; x : integer);
  124.         Procedure dbputlong(fldno:integer; x : longint);
  125.         Procedure dbputreal(fldno:integer; x : real);
  126.  
  127.         Function  dbrewrite(rec_no:longint):boolean;
  128.         Function  dbdelete(rec_no:longint):boolean;
  129.         Function  dbappend :boolean;
  130.  
  131.         Function  dbExportrec : string;
  132.         Function  dbExportDef : string;
  133.         Procedure dbFieldInfo(fldno:integer; var fldnam:string; var rtype:char;
  134.                               var width,decp : byte);
  135.  
  136. {private methods}
  137.         Procedure calc_coloff;
  138.         Procedure dbSetHeaderDate;
  139.         Function  dbUpdateHeader :boolean;
  140.         end;
  141. {+}
  142.  
  143. {SECTION .zzImplementation }
  144. IMPLEMENTATION
  145.  
  146.  
  147. {SECTION  XBASE_DBF_object }
  148. Procedure XBASE_DBF_object.Init(dbfilename : string; readonly : boolean);
  149. var numread :word;
  150.     i,j,errnull :integer;
  151.      begin
  152.      writepermitted := false;
  153.      opened   := false;
  154.      err      := 0;
  155.      infile   := dbfilename;      { save filename }
  156.      if readonly then FileMode := 0
  157.      else begin
  158.           FileMode := 2;
  159.           writepermitted := true;
  160.           end;
  161.  
  162.     { ForceExt(infile,'dbf');}
  163.      assign(dbfin,infile);
  164.  
  165.      {$I-}
  166.      reset(dbfin,1);            { record size to read = 1 }
  167.      {$I+}
  168.      err := IOResult;
  169.      if err <> 0 then exit;
  170.      {$I-}
  171.      blockread(dbfin,dbhead,sizeof(dbhead),numread);
  172.      {$I+}
  173.      err := IOResult;
  174.      if err <> 0 then exit;
  175.      if dbhead.rec_bytes > bufmax then
  176.           begin
  177.           err := -50;
  178.           writeln('***DBF rec size too large, I am allowing bufmax=',bufmax,' bytes.');
  179.           writeln('   This record is: ',dbhead.rec_bytes,' bytes.');
  180.           writeln('   To handle this, PbXBASE must be changed.');
  181.           end;
  182.      if(numread = 0) then err := READ_ERR
  183.      else begin  { calc the number of cols of data to read, put in global }
  184.           no_col := ((dbhead.header_bytes - sizeof(dbhead)) div 32);
  185.         {  writeln('field calcs ',no_col,'  ',dbhead.header_bytes,'  ',
  186.                   sizeof(dbhead));  }
  187.           for i := 1 to no_col do       { read the column definitions }
  188.              begin
  189.             {$I-}
  190.              blockread(dbfin,rec_stru,sizeof(rec_stru),numread);
  191.             {$I+}
  192.              err := IOResult;
  193.              if err <> 0 then exit;
  194.              if(numread = 0) then err := READ_ERR
  195.              else begin                   { move it to users structure }
  196.                   rstru[i].rtype := rec_stru.rtype;
  197.                   rstru[i].width := rec_stru.width;
  198.                   rstru[i].decp := rec_stru.decp;
  199.                   j := 1;                 { convert from C string to Pascal string }
  200.                   while((ord(rec_stru.name[j]) > 0) and (j <= 10)) do
  201.                        begin
  202.                        rstru[i].name[j] := rec_stru.name[j];
  203.                        inc(j);
  204.                        end;
  205.                   rstru[i].name[0] := chr(lo(j-1));    { set string length }
  206.                   end;
  207.              end;
  208.           calc_coloff;                        { calculate column offsets }
  209.           dbgoto(1); { ignore error }
  210.           err := 0;
  211.           end;
  212.      if err <> 0 then
  213.           begin
  214.           writeln('Init  - error ',err);
  215.           end
  216.      else opened   := true;
  217.      end;
  218.  
  219.  
  220. Function  XBASE_DBF_object.NoError : boolean;
  221.      begin
  222.      NoError := (Err = 0);
  223.      end;
  224.  
  225.  
  226. Function XBASE_DBF_object.dbclose : boolean;
  227.       { Call at end of your application to close the Dbase file.  For now
  228.         there is only one file to close, if extended to use
  229.         multiple database files then this procedure would be required.
  230.         Returns STD_ERR_CODES.}
  231.      begin
  232.      err := 0;
  233.      dbclose := false;
  234.      if opened then
  235.           begin
  236.           {$I-} close(dbfin);  {$I-}
  237.           err := IOResult;
  238.           end
  239.      else err := -999;  {file not open}
  240.      dbclose := NoError;
  241.      end;
  242.  
  243.  
  244. Procedure XBASE_DBF_object.done;
  245.      begin
  246.      if not dbclose then writeln('Done - Close error ',err);
  247.      end;
  248.  
  249.  
  250. Function  XBASE_DBF_object.dbfldname( fnum:integer ):string;
  251.      begin
  252.      if (fnum > 0) and (fnum <= no_col) then
  253.           dbfldname := rstru[fnum].name
  254.      else dbfldname := '';
  255.      end;
  256.  
  257.  
  258. Function  XBASE_DBF_object.dbfldrtype(fnum:integer):char;
  259.      begin
  260.      if (fnum > 0) and (fnum <= no_col) then
  261.           dbfldrtype := rstru[fnum].rtype
  262.      else dbfldrtype := '?';
  263.      end;
  264.  
  265.  
  266. Function  XBASE_DBF_object.dbfldwidth(fnum:integer) : integer;
  267.      begin
  268.      if (fnum > 0) and (fnum <= no_col) then
  269.           dbfldwidth := rstru[fnum].width
  270.      else dbfldwidth := 1;
  271.      end;
  272.  
  273.  
  274. Function  XBASE_DBF_object.dbflddecp(fnum:integer) : integer;
  275.      begin
  276.      if (fnum > 0) and (fnum <= no_col) then
  277.           dbflddecp := rstru[fnum].decp
  278.      else dbflddecp := 0;
  279.      end;
  280.  
  281.  
  282. Function  XBASE_DBF_object.dbnumfields : integer;
  283.      begin
  284.      dbnumfields := no_col;
  285.      end;
  286.  
  287.  
  288. Function  XBASE_DBF_object.dbrecsize : integer;
  289.      begin
  290.      dbrecsize := dbhead.rec_bytes;
  291.      end;
  292.  
  293.  
  294. Function  XBASE_DBF_object.dbnumrecs : integer;
  295.      begin
  296.      dbnumrecs := dbhead.no_rec;
  297.      end;
  298.  
  299.  
  300. Procedure XBASE_DBF_object.dbcleardbbuf;
  301.      begin
  302.      fillchar(dbbuf,sizeof(dbbuf),0);
  303.      end;
  304.  
  305.  
  306. Function XBASE_DBF_object.dbfldno(fname:string):integer;
  307.        { Returns an integer which is the number in the rstru array where fname
  308.          is located.  Used to enable user to use field names in Functions to
  309.          return data.  Returns 0 if fname not found.}
  310. var i   :integer;
  311.      begin
  312.      dbfldno := 0;       { default to not found }
  313.      for i := 1 to no_col do if(fname = rstru[i].name) then dbfldno := i;
  314.      end;
  315.  
  316.  
  317. Procedure XBASE_DBF_object.dbshowstruc;
  318. var i   :integer;
  319.     tmp :string[20];
  320.     tpe :string[10];
  321.  
  322.      begin
  323.      err := 0;
  324.      writeln('Structure for database :',infile);
  325.      with dbhead do
  326.          begin
  327.          writeln('Date of last update    :',updmo:2,'/',upddy:2,'/',updyr:2);
  328.          writeln('Number of records      :',no_rec:8);
  329.          writeln('Column     Type       Width  Decimals Offset');
  330.          writeln('---------- ---------- ------ -------- ------');
  331.          writeln('           Delete Flg      1               1');
  332.          end;
  333.      for i := 1 to no_col do
  334.          begin
  335.          with rstru[i] do
  336.               begin
  337.               tmp := copy(concat(rstru[i].name,'          '),1,10);
  338.               case rtype of
  339.                   'C' :tpe := 'Character';
  340.                   'N' :tpe := 'Numeric  ';
  341.                   'D' :tpe := 'Date     ';
  342.                   'L' :tpe := 'Logical  ';
  343.                   'M' :tpe := 'Memo     ';
  344.                   else tpe := 'Unknown  ';
  345.                   end;
  346.               writeln(tmp,' ',tpe,'    ',width:4,'      ',
  347.                       decp:3,'   ',rstru[i].stloc:4);
  348.               end;
  349.          end;
  350.      writeln;
  351.      writeln('                       Record length -> ',dbhead.rec_bytes:4);
  352.      end;
  353.  
  354.  
  355. Procedure XBASE_DBF_object.calc_coloff;  { calculate the offset from the beginning of
  356.                           the record for each data element.}
  357. var  i,j :integer;
  358.      begin
  359.      j := 2;       { first element of record is deleted flag }
  360.      for i := 1 to no_col do
  361.         begin
  362.         with rstru[i] do
  363.             begin
  364.             stloc := j;
  365.             j := j + width;
  366.             end; {with}
  367.         end;  {for}
  368.      end;   {Procedure calc_coloff}
  369.  
  370.  
  371. Function XBASE_DBF_object.dbposition(rec_no:longint):boolean;
  372. var fileloc    :longint;
  373.      begin
  374.      err := 0;
  375.      dbposition := false;
  376.      if(rec_no < 1) then
  377.          begin
  378.          dbposition := true;
  379.          rec_no := 1;
  380.          end;
  381.      if(rec_no > dbhead.no_rec) then
  382.          begin
  383.          err := POSITION_ERR;
  384.          dbposition := false;
  385.          rec_no := dbhead.no_rec;
  386.          end;
  387.      db_rec_no := rec_no;
  388.      fileloc := (dbhead.header_bytes + ((rec_no -1) * dbhead.rec_bytes));
  389.     {$I-} seek(dbfin,fileloc); {$I+}
  390.      err := IOResult;
  391.      dbposition := NoError;
  392.      end;
  393.  
  394.  
  395. Function XBASE_DBF_object.dbgoto(rec_no:longint):boolean;
  396. var numread    :word;
  397.     fileloc    :longint;
  398.      begin
  399.      err := 0;
  400.      dbgoto := false;
  401.      if rec_no > dbhead.no_rec then
  402.           begin
  403.           err := POSITION_err;
  404.           end
  405.      else begin
  406.           if dbposition(rec_no) then
  407.                begin
  408.          {$I-} blockread(dbfin,dbbuf,dbhead.rec_bytes,numread); {$I+}
  409.                err := IOResult;
  410.                if(numread = 0) then err := READ_ERR;
  411.                end
  412.           else err := READ_ERR;
  413.           end;
  414.      dbgoto := NoError;
  415.      end;
  416.  
  417.  
  418. Procedure XBASE_DBF_object.dblistrecs;       { list all records in the file }
  419. var tmp_recno  :longint;
  420.     numread    :word;
  421.     j          :integer;
  422.      begin
  423.      err := 0;
  424.      if not opened then exit;
  425.  
  426.      {$I-} seek(dbfin,dbhead.header_bytes); { position to first record } {$I+}
  427.      err := IOResult;
  428.      if err <> 0 then exit;
  429.      { file is already open and positioned to the first data record }
  430.      tmp_recno := dbhead.no_rec;
  431.      while (tmp_recno > 0) do  { need a while loop for more than int }
  432.          begin
  433.          {$I-} blockread(dbfin,dbbuf,dbhead.rec_bytes,numread); {$I+}
  434.          err := IOResult;
  435.          if(numread > 0) then
  436.               begin
  437.               write('!');
  438.               for j := 1 to dbhead.rec_bytes do write(dbbuf[j]);
  439.               writeln('!');
  440.               dec(tmp_recno);
  441.               end;
  442.          end;
  443.      end;
  444.  
  445.  
  446. Function XBASE_DBF_object.dbstr(fldno:integer):string;
  447. var tmp  :string;
  448.     i    :integer;
  449.      begin
  450.      for i := 1 to rstru[fldno].width do
  451.          tmp[i] := dbbuf[rstru[fldno].stloc + i - 1];
  452.      tmp[0] := chr(rstru[fldno].width);
  453.      dbstr := tmp;
  454.      end;
  455.  
  456.  
  457. Function XBASE_DBF_object.dbint(fldno:integer):integer;
  458. var tmp      :string;
  459.     i,result :integer;
  460.      begin
  461.      for i := 1 to rstru[fldno].width do
  462.         tmp[i] := dbbuf[rstru[fldno].stloc + i - 1];
  463.      tmp[0] := chr(rstru[fldno].width);
  464.      val(tmp,i,result);
  465.      dbint := i;
  466.      end;
  467.  
  468.  
  469. Function XBASE_DBF_object.dblong(fldno:integer):longint;
  470. var tmp      :string;
  471.     i,result :integer;
  472.     retval   :longint;
  473.      begin
  474.      for i := 1 to rstru[fldno].width do
  475.         tmp[i] := dbbuf[rstru[fldno].stloc + i - 1];
  476.      tmp[0] := chr(rstru[fldno].width);
  477.      val(tmp,retval,result);
  478.      dblong := retval;
  479.      end;
  480.  
  481.  
  482. Function XBASE_DBF_object.dbreal(fldno:integer):real;
  483. var tmp      :string;
  484.     i,result :integer;
  485.     retval   :real;
  486.      begin
  487.      for i := 1 to rstru[fldno].width do
  488.         tmp[i] := dbbuf[rstru[fldno].stloc + i - 1];
  489.      tmp[0] := chr(rstru[fldno].width);
  490.      val(tmp,retval,result);
  491.      dbreal := retval;
  492.      end;
  493.  
  494.  
  495. Function XBASE_DBF_object.dblogic(fldno:integer):boolean;
  496. var i  :integer;
  497.      begin
  498.      i := rstru[fldno].stloc;
  499.      if((dbbuf[i] = 'T') or (dbbuf[i] = 't') or (dbbuf[i] = 'Y') or
  500.         (dbbuf[i] = 'y')) then
  501.           dblogic := true
  502.      else dblogic := false;
  503.      end;
  504.  
  505.  
  506. Function XBASE_DBF_object.dbdeleted:boolean;
  507.      begin
  508.      err := 0;
  509.      dbdeleted := false;
  510.      if(dbbuf[1] = '*') then
  511.           dbdeleted := true
  512.      else dbdeleted := false;
  513.      end;
  514.  
  515.  
  516. Function XBASE_DBF_object.dbrecno:longint;
  517.            { Returns the present record number in the database. }
  518.      begin
  519.      dbrecno := db_rec_no;
  520.      end;
  521.  
  522.  
  523. Function XBASE_DBF_object.dbskip(rec_no:longint):boolean;
  524.           { positions .DBF file forward (+rec_no) or backwards (-rec_no) rec_no
  525.             records from present position.  Fills dbbuf[] from new DBF record.
  526.             Returns  STD_ERR_CODES.
  527.           }
  528.      begin
  529.      err := 0;
  530.      dbskip := false;
  531.      if(rec_no > 0) then inc(db_rec_no,rec_no);
  532.      if(rec_no < 0) then dec(db_rec_no,rec_no);
  533.      dbskip := dbgoto(db_rec_no);
  534.      end;
  535.  
  536.  
  537. Function XBASE_DBF_object.dbtop:boolean;
  538.           { Positions .DBF file to record 1, fills dbbuf[] with data }
  539.      begin
  540.      err := 0;
  541.      dbtop := false;
  542.      dbtop := dbgoto(1);
  543.      end;
  544.  
  545.  
  546. Function XBASE_DBF_object.dbbottom:boolean;
  547.           { Positions .DBF file to last record, fills dbbuf[] with data }
  548.      begin
  549.      err := 0;
  550.      dbbottom := false;
  551.      dbbottom := dbgoto(dbhead.no_rec);
  552.      end;
  553.  
  554.  
  555. {PAGE}
  556. { ************  Write support *****************************************}
  557.  
  558. Procedure XBASE_DBF_object.dbputstr(fldno:integer; s : string);
  559. { Places the string into any field of the database.  This
  560.   field is filled out to the full field length by padding with spaces.
  561. }
  562. var i,j  :integer;
  563.      begin
  564.      for i := 1 to rstru[fldno].width do
  565.           dbbuf[rstru[fldno].stloc + i - 1] := ' ';
  566.      j := min(length(s),rstru[fldno].width);
  567.      if j > 0 then
  568.           begin
  569.           for i := 1 to j do
  570.                begin
  571.                dbbuf[rstru[fldno].stloc + i - 1] := s[i];
  572.                end;
  573.           end;
  574.      end;
  575.  
  576.  
  577. Procedure XBASE_DBF_object.dbputdate(fldno:integer; s : string);
  578. { Date comes in as a 8 character string "yyyymmdd"}
  579. var i,j  :integer;
  580.      begin
  581.      for i := 1 to rstru[fldno].width do
  582.           dbbuf[rstru[fldno].stloc + i - 1] := '0';
  583.      j := min(length(s),rstru[fldno].width);
  584.      if j > 0 then
  585.           begin
  586.           for i := 1 to j do dbbuf[rstru[fldno].stloc + i - 1] := s[i];
  587.           end;
  588.      end; {Function dbputdate}
  589.  
  590.  
  591. Procedure XBASE_DBF_object.dbputint(fldno:integer; x : integer);
  592. var i,j,k  :integer;
  593.     s      : string;
  594.      begin
  595.      for i := 1 to rstru[fldno].width do
  596.           dbbuf[rstru[fldno].stloc + i - 1] := ' ';
  597.      j := rstru[fldno].width;
  598.      s := integerstr(x,j);
  599.      for i := 1 to j do dbbuf[rstru[fldno].stloc + i - 1] := s[i];
  600.      end;
  601.  
  602.  
  603. Procedure XBASE_DBF_object.dbputlong(fldno:integer; x : longint);
  604. var i,j,k  :integer;
  605.     s      : string;
  606.      begin
  607.      for i := 1 to rstru[fldno].width do
  608.           dbbuf[rstru[fldno].stloc + i - 1] := ' ';
  609.      j := rstru[fldno].width;
  610.      s := longintstr(x,j);
  611.      for i := 1 to j do dbbuf[rstru[fldno].stloc + i - 1] := s[i];
  612.      end;
  613.  
  614.  
  615. Procedure XBASE_DBF_object.dbputreal(fldno:integer; x : real);
  616. var i,j,k  :integer;
  617.     s      : string;
  618.      begin
  619.      for i := 1 to rstru[fldno].width do
  620.           dbbuf[rstru[fldno].stloc + i - 1] := ' ';
  621.      j := rstru[fldno].width;
  622.      k := rstru[fldno].decp;
  623.      s := realstr(x,j,k);
  624.      for i := 1 to j do dbbuf[rstru[fldno].stloc + i - 1] := s[i];
  625.      end;
  626.  
  627.  
  628. Procedure XBASE_DBF_object.dbSetHeaderDate;
  629. var year, month, day, doy : word;
  630.     begin
  631.     GetDate(year,month,day,doy);
  632.     dbhead.updyr := byte(year-1900);
  633.     dbhead.updmo := byte(month);
  634.     dbhead.upddy := byte(day);
  635.     end;
  636.  
  637.  
  638. Function  XBASE_DBF_object.dbUpdateHeader : boolean;
  639.             { rewrites the first portion of the file header,
  640.               returns STD_ERR_CODES.}
  641. var numwritten :word;
  642.     fileloc    :longint;
  643.      begin
  644.      err := 0;
  645.      dbUpdateHeader := false;
  646.      if not opened or not writepermitted then
  647.           begin
  648.           err := -99;
  649.           exit;
  650.           end;
  651.      fileloc := 0;
  652.     {$I-} seek(dbfin,fileloc);    {$I+}
  653.      err := IOResult;
  654.      dbUpdateHeader := NoError;
  655.      if not NoError then exit;
  656.  
  657.     {$I-} blockwrite(dbfin,dbhead,sizeof(dbhead),numwritten);    {$I+}
  658.      err := IOResult;
  659.      if(numwritten = 0) then err := -9;
  660.      dbUpdateHeader := NoError;
  661.      end;
  662.  
  663.  
  664.  
  665. Function  XBASE_DBF_object.dbrewrite(rec_no:longint):boolean;
  666. { rewrites the dbbuf[] over the current record of the database, returns
  667.   STD_ERR_CODES.
  668. }
  669. var
  670.    numwritten :word;
  671.    fileloc    :longint;
  672.      begin
  673.      err := 0;
  674.      dbrewrite := false;
  675.      if not opened or not writepermitted then
  676.           begin
  677.           err := -99;
  678.           exit;
  679.           end;
  680.      if dbposition(rec_no) then
  681.           begin
  682.          {$I-} blockwrite(dbfin,dbbuf,dbhead.rec_bytes,numwritten); {$I+}
  683.           err := IOResult;
  684.           dbrewrite := NoError;
  685.           end
  686.      else dbrewrite := false;
  687.      if NoError then
  688.           begin
  689.           dbSetHeaderDate;
  690.           if dbUpdateHeader then
  691.                begin
  692.                dbrewrite := dbgoto(rec_no);
  693.                end;
  694.           end;
  695.      dbrewrite := NoError;
  696.      end;
  697.  
  698.  
  699. Function  XBASE_DBF_object.dbdelete(rec_no:longint):boolean;
  700. { rewrites the dbbuf[] over the (rec_no) record of the database, returns
  701.   STD_ERR_CODES.
  702. }
  703. var
  704.    numwritten :word;
  705.    fileloc    :longint;
  706.      begin
  707.      err := 0;
  708.      dbdelete := false;
  709.      if not opened or not writepermitted then
  710.           begin
  711.           err := -99;
  712.           exit;
  713.           end;
  714.      if dbposition(rec_no) then
  715.           begin
  716.           dbbuf[1] := '*';      { 2Ah }
  717.          {$I-} blockwrite(dbfin,dbbuf,dbhead.rec_bytes,numwritten); {$I+}
  718.           err := IOResult;
  719.           end
  720.      else dbdelete := false;
  721.      if NoError then
  722.           begin
  723.           dbSetHeaderDate;
  724.           if dbUpdateHeader then
  725.                begin
  726.                dbdelete := dbgoto(rec_no);
  727.                end;
  728.           end;
  729.      dbdelete := NoError;
  730.      end;
  731.  
  732.  
  733. Function XBASE_DBF_object.dbappend : boolean;
  734.             { appends the dbbuf[] record to the end of the database,
  735.               returns STD_ERR_CODES.}
  736. var
  737.    numwritten :word;
  738.    fileloc    :longint;
  739.      begin
  740.      err := 0;
  741.      dbappend := false;
  742.      if not opened or not writepermitted then
  743.           begin
  744.           err := -99;
  745.           exit;
  746.           end;
  747.  
  748.     {$I-} seek(dbfin,FileSize(dbfin));    {$I+}
  749.      err := IOResult;
  750.      if not NoError then exit;
  751.  
  752.     {$I-} blockwrite(dbfin,dbbuf,dbhead.rec_bytes,numwritten); {$I+}
  753.      err := IOResult;
  754.      if not NoError then exit;
  755.      if(numwritten = 0) then err := REWRITE_ERR;
  756.  
  757.      inc(dbhead.no_rec);
  758.      dbSetHeaderDate;
  759.      if dbUpdateHeader then
  760.           begin
  761.           dbappend := dbbottom;
  762.           end;
  763.      dbappend := NoError;
  764.      end;
  765.  
  766.  
  767. Procedure XBASE_DBF_object.dbFieldInfo(fldno:integer; var fldnam : string;
  768.                                     var rtype : char; var width,decp : byte);
  769.      begin
  770.      rtype := chr(0);
  771.      width := 0;
  772.      decp  := 0;
  773.      fldnam := '';
  774.      if (fldno > 0) and (fldno <= no_col) then
  775.          begin
  776.          rtype := rstru[fldno].rtype;
  777.          width := rstru[fldno].width;
  778.          decp  := rstru[fldno].decp;
  779.          fldnam := rstru[fldno].name;
  780.          end;
  781.      end;
  782.  
  783.  
  784.  
  785. Function  XBASE_DBF_object.dbExportrec : string;
  786. var s : string;
  787.      begin
  788.      s := '<dbExportRec not ready>';
  789.      dbExportrec := s;
  790.      end;
  791.  
  792.  
  793. Function  XBASE_DBF_object.dbExportDef : string;
  794. var s : string;
  795.      begin
  796.      s := '<dbExportDef not ready>';
  797.      end;
  798.  
  799.  
  800.  
  801.  
  802. {SECTION  zzInitialization }
  803.      begin {initialization}
  804.      end.
  805.